perm filename CNTRL.LSP[C,JRA]1 blob
sn#012881 filedate 1972-11-16 generic text, type T, neo UTF8
00100 (GLOBAL
00200 (FUNCTIONS /@ EAR TOP CINTERRUPT VFRAME CPRINT CPRIN1 PROGBIND
00300 RUN START STOP PROG COND GO EXIT RETURN DISMISS CEVAL CERR
00400 CDEFUN VLOC RVALUE CSET CSETQ TAG ACTBLOCK UNASSIGN ACCESS
00500 CONTROL SETACCESS SETCONTROL EXPRESSION CLOSURE FRAME
00600 CALL BACKTRACE LISTEN CONTINUE ALLOW INVOKE
00700 /: /, /!/> /!/' /!/? /!/; /!/" /!/@ /!/< /!/,)
00800 (RESERVED ← *FRAME CEXPR "OPTIONAL" "REST" "AUX"
00900 * ** CLAMBDA *TAG *AU-REVOIR /? /< /> /' /@ /" /$ /; / / /) ))
01000
01100 (DECLARE (SPECIAL OBARRAY READTABLE ERRLIST) (SYMBOLS T) (MACROS T))
01200
01300 (DECLARE
01400 (SPECIAL UARGS BODY EARGS CHALOBV BVARS ALINK CLINK
01500 EXP FRAME* FREEVARS FRAMEVARS LEVNUM PC RUNF TEM
01600 TEM1 TYPE VAL VARS CINTERRUPT SERRLI ALLOW READY
01700 GLOBALS * ** ←)
01800 (*FEXPR CDEFGEN CDEFUN CERR CONNIVER CSETQ /: /@ /,)
01900 (*LEXPR MATCH ACCESS CONTROL CSET RVALUE VLOC RUN))
02000
02100 (SETQ RUNF () SERRLI () ** '** GLOBALS '((NIL NIL) (T T))) (COMMENT THE FRAME FORMAT IS AS FOLLOWS
02200 ((IVARS . PC) (BVARS . ALINK) EXP . CLINK)
02300 )
02400
02500 (SETQ FREEVARS '(VAL VARS UARGS BODY EARGS TEM TEM1 ALLOW)
02600 FRAMEVARS '(CHALOBV FRAME* BVARS ALINK CLINK EXP CINTERRUPT READY))
02700
02800 (DEFUN BVARS MACRO (L) (LIST 'CAADR (CADR L)))
02900
03000 (DEFUN ALINK MACRO (L) (LIST 'CDADR (CADR L)))
03100
03200 (DEFUN EXP MACRO (L) (LIST 'CADDR (CADR L)))
03300
03400 (DEFUN CLINK MACRO (L) (LIST 'CDDDR (CADR L)))
03500
03600 (DEFUN BODY MACRO (L) '(CADR (ASSQ '*BODY BVARS)))
00100 (COMMENT THE HACK REALLY BEGINS HERE -- RUN1 IS THE SYSTEM DRIVER)
00200
00300 (DEFUN RUN L
00400 (SETQ VAL (COND ((= L 1) (ARG 1)) (T NIL)))
00500 (RUN1))
00600
00700 (DEFUN RUN1 ()
00800 (COND (RUNF (CERR CONNIVER ALREADY RUNNING)) )
00900 ((LAMBDA (BASE IBASE READTABLE)
01000 (PROG (RUNF ERET)
01100 (SETQ RUNF T ERRLIST SERRLI)
01200 ERRL (SETQ ERET
01300 (CATCH (PROG ()
01400 LOOP (COND ((AND CINTERRUPT ALLOW)
01500 (SETQ PC (HANDLE)))
01600 ((SETQ PC (CAP PC))))
01700 (GO LOOP))))
01800 (COND ((EQ ERET 'STOP) (RETURN VAL)))
01900 (GO ERRL)))
02000 10.
02100 10.
02200 (GET 'CONNIVREAD 'ARRAY)) )
02300
02400 (DEFUN CAP (P) (APPLY P ()))
02500
02600 (DEFUN HANDLE ()
02700 (PROG2 0
02800 (DISPATCH (PROG2 0 (CAR CINTERRUPT) (SETQ CINTERRUPT (CDR CINTERRUPT)))
02900 PC
03000 FREEVARS
03100 '*TOP)
03200 (SETQ ALLOW ())))
03300
03400
03500 (DEFUN START NIL
03600 (COND (RUNF (CERR CONNIVER ALREADY RUNNING)))
03700 (MAPC '(LAMBDA (V) (SET V NIL)) (APPEND FRAMEVARS FREEVARS))
03800 (SETQ PC 'ICEVAL EXP '(CEVAL '(LISTEN 'TOP-LEVEL)) LEVNUM 0 ALLOW T)
03900 (RUN1) )
04000
04100 (DEFUN STOP N
04200 (BREAK CONNIVER-NOT-RUNNING--STOP (NOT RUNF))
04300 (COND ((= N 0) (SETQ VAL ()))
04400 ((= N 1) (SETQ VAL (ARG 1)))
04500 (T (CERR WRONG # OF ARGS)))
04600 (SETQ PC 'POPJ)
04700 (THROW 'STOP))
04800
04900 (DEFUN *STOP NIL (SETQ PC 'U-LOSE) (THROW 'STOP))
05000
05100 (DEFUN U-LOSE NIL
05200 (CERR ATTEMPT TO RUN A CONNIVER PROCESS WITH AN UNDEFINED PC)
05300 'U-LOSE)
00100 (DEFUN CERR FEXPR (L A)
00200 (PRINT '**ERROR**)
00300 (MAPC '(LAMBDA (X)
00400 (CPRIN1 (COND ((ATOM X) X)
00500 ((EQ (CAR X) '/@) (EVAL (CDR X) A))
00600 (T X)))
00700 (PRINC '/ ))
00800 L)
00900 (CPRINT EXP)
01000 (PROG ()
01100 (PRINT 'IN-LISP)
01200 LP (PRINC '/*)
01400 (ERRSET (COND ((EQ (SETQ ** (READ)) '$P)(RETURN NIL))
01500 ((EQ (CAR **) 'RETURN)
01600 (RETURN (EVAL (CADR **) A)))
01700 (T (SETQ * (CPRINT (EVAL ** A))))))
01800 (SETQ ← **)
01900 (GO LP)))
02000
02100 (DEFUN EAR ()
02200 (SETQ CINTERRUPT (CONS '(LISTEN 'IN-CONNIVER) CINTERRUPT)
02300 SERRLI ERRLIST
02400 ERRLIST '((RUN1)))
02500 (IOC G))
02600
02700 (DEFUN TOP ()
02800 (SETQ SERRLI ERRLIST ERRLIST '((START)))
02900 (IOC G))
03000
03100 (DEFUN CINTERRUPT (EXP)
03200 (NCONC (GET 'CINTERRUPT 'VALUE) (LIST EXP)))
03300
03400 (DEFUN ALLOW FEXPR (L) (SETQ ALLOW (CAR L))) (COMMENT DISPATCH IS THE "PUSHJ" FOR CONNIVER)
03500
03600 (DECLARE (SPECIAL ALINK1 EXP1 RETAG SAVE))
03700
03800 (DEFUN DISPATCH
03900 (EXP1 RETAG SAVE ALINK1)
04000 (COND ((NUMBERP EXP1) (SETQ VAL EXP1) RETAG)
04100 ((ATOM EXP1) (SETQ VAL (IVAL EXP1 ALINK1)) RETAG)
04200 (T (PROG (V F)
04300 (SETQ F (CAR EXP1))
04400 BEGIN
04500 (COND ((ATOM F)
04600 (COND ((SETQ V
04700 (GETL F '(CINT CEXPR FEXPR FSUBR)))
04800 (GO (CAR V)))
04900 (T (SAVEUP)
05000 (SETQ UARGS (CDR EXP1) EARGS ())
05100 (RETURN 'EVARGS))))
05200 ((EQ (CAR F) 'CLAMBDA)
05300 (SAVEUP)
05400 (BIND1 '*BODY (CDDR F))
05500 (SETQ VARS (CADR F) UARGS (CDR EXP1))
05600 (RETURN 'ARGB))
05700 ((EQ (CAR F) 'LAMBDA)
05800 (SAVEUP)
05900 (SETQ UARGS (CDR EXP1) EARGS ())
06000 (RETURN 'EVARGS))
06100 ((EQ (CAR F) '*CLOSURE)
06200 (SETQ F (CADR F))
06300 (GO BEGIN))
06400 (T (SETQ F (CERR UNKNOWN FUNCTION TYPE (/@ . EXP1)))
06500 (GO BEGIN)))
06600 CINT
06700 (SAVEUP)
06800 (RETURN (CADR V))
06900 CEXPR
07000 (SAVEUP)
07100 (BIND1 '*BODY (CDADR V))
07200 (SETQ VARS (CAADR V) UARGS (CDR EXP1))
07300 (RETURN 'ARGB)
07400 FEXPR FSUBR
07500 (SETQ VAL (EVAL EXP1))
07600 (RETURN RETAG)))))
07700
07800
07900 (DEFUN SAVEUP ()
08000 (SETQ
08100 CLINK (CONS (CONS (SAVEV) RETAG)
08200 (COND ((NULL FRAME*) (SETQ CHALOBV NIL)
08300 (CONS (CONS BVARS ALINK) (CONS EXP CLINK)))
08400 (CHALOBV (SETQ CHALOBV NIL)
08500 (CONS (CONS BVARS ALINK) (CDDR FRAME*)))
08600 (T (CDR FRAME*))))
08700 EXP EXP1
08800 ALINK (COND ((EQ ALINK1 '*TOP) CLINK) (T ALINK1))
08900 BVARS NIL
09000 FRAME* NIL))
09100
09200 (DEFUN SAVEV () (MAPCAR '(LAMBDA (V) (CONS V (VALUE V))) SAVE)) (COMMENT FUNCTION CALLS RETURN VIA "POPJ")
09300
09400 (DEFUN POPJ ()
09500 (COND ((SETQ FRAME* CLINK) (RESTORE))
09600 (T '*STOP)))
09700
09800 (DEFUN RESTORE ()
09900 (SETQ
10000 BVARS (CAADR FRAME*)
10100 ALINK (CDADR FRAME*)
10200 EXP (CADDR FRAME*)
10300 CLINK (CDDDR FRAME*))
10400 (REST1))
10500
10600 (DEFUN REST1 ()
10700 (MAPC '(LAMBDA (X) (SET (CAR X) (CDR X))) (CAAR FRAME*))
10800 (CDAR FRAME*))
10900
11000 (PUTPROP 'VALUE (GET 'EVAL 'LSUBR) 'LSUBR)
11100
11200 (DECLARE (UNSPECIAL ALINK1 EXP1 RETAG SAVE))
11300
11400 (DEFUN BIND1 (VAR VAL)
11500 (SETQ BVARS (CONS (LIST VAR VAL) BVARS) CHALOBV T))
11600
11700 (DEFUN CLOSE ()
11800 (COND ((ATOM (CAR EXP)))
11900 ((EQ (CAAR EXP) '*CLOSURE)
12000 (SETQ ALINK (CADDAR EXP) CHALOBV T))))
00100 (COMMENT MOBY BINDER -- NORMAL FUNCTION LISTS)
00200
00300 (DEFUN ARGB NIL (COND ((NOT (OR VARS UARGS)) (CLOSE) 'AUXB)
00400 ((AND VARS UARGS)
00500 (COND ((ATOM (CAR VARS))
00600 (COND ((EQ (CAR VARS) '"OPTIONAL")
00700 (SETQ VARS (CDR VARS))
00800 (OPTMATCH))
00900 ((EQ (CAR VARS) '"REST")
01000 (SETQ VARS (CDR VARS))
01100 (RESTMATCH))
01200 (T (DISPATCH (CAR UARGS)
01300 'ARGB1
01400 '(VARS UARGS)
01500 ALINK))))
01600 ((AND (EQ (CAAR VARS) 'QUOTE)
01700 (ATOM (CADAR VARS)))
01800 (ARGQ))
01900 (T (CERR BAD DECLARATION))))
02000 ((AND VARS (OR (EQ (CAR VARS) '"OPTIONAL")
02100 (EQ (CAR VARS) '"REST")))
02200 (CLOSE)
02300 (FINVAR))
02400 (T (CERR WRONG # OF ARGS))))
02500
02600 (DEFUN ARGB1
02700 NIL
02800 (BIND1 (CAR VARS) VAL)
02900 (SETQ VARS (CDR VARS) UARGS (CDR UARGS))
03000 'ARGB)
03100
03200 (DEFUN ARGQ
03300 NIL
03400 (BIND1 (CADAR VARS) (CAR UARGS))
03500 (SETQ VARS (CDR VARS) UARGS (CDR UARGS))
03600 'ARGB)
00100 (COMMENT BIND UP "OPTIONAL"S AND "REST"S)
00200
00300 (DEFUN OPTMATCH
00400 NIL
00500 (COND ((NULL UARGS) (CLOSE) (COND ((NULL VARS) 'AUXB)
00600 (T 'FINVAR)))
00700 ((ATOM (CAR VARS)) (COND ((EQ (CAR VARS) '"OPTIONAL")
00800 (SETQ VARS (CDR VARS))
00900 'OPTMATCH)
01000 ((EQ (CAR VARS) '"REST")
01100 (SETQ VARS (CDR VARS))
01200 'RESTMATCH)
01300 (T (DISPATCH (CAR UARGS)
01400 'OPTMATCH1
01500 '(VARS UARGS)
01600 ALINK))))
01700 ((EQ (CAAR VARS) 'QUOTE)
01800 (COND ((ATOM (CADAR VARS)) (BIND1 (CADAR VARS) (CAR UARGS))
01900 (SETQ VARS (CDR VARS) UARGS (CDR UARGS))
02000 'OPTMATCH)
02100 (T (CERR BAD DECLARATION))))
02200 ((ATOM (CAAR VARS)) (DISPATCH (CAR UARGS)
02300 'OPTMATCH1
02400 '(VARS UARGS)
02500 ALINK))
02600 ((AND (EQ (CAAAR VARS) 'QUOTE) (ATOM (CADAAR VARS)))
02700 (BIND1 (CADAAR VARS) (CAR UARGS))
02800 (SETQ VARS (CDR VARS) UARGS (CDR UARGS))
02900 'OPTMATCH)
03000 (T (CERR BAD DECLARATION))))
03100
03200 (DEFUN OPTMATCH1
03300 NIL
03400 (BIND1 (COND ((ATOM (CAR VARS)) (CAR VARS)) (T (CAAR VARS))) VAL)
03500 (SETQ VARS (CDR VARS) UARGS (CDR UARGS))
03600 'OPTMATCH)
03700
03800 (DEFUN RESTMATCH NIL (COND ((ATOM (CAR VARS)) (SETQ EARGS NIL) (EVREST))
03900 ((AND (EQ (CAAR VARS) 'QUOTE)
04000 (ATOM (CADAR VARS)))
04100 (BIND1 (CADAR VARS) UARGS)
04200 (CLOSE) 'AUXB)
04300 (T (CERR BAD DECLARATION))))
04400
04500 (DEFUN EVREST NIL (COND ((NULL UARGS)
04600 (BIND1 (CAR VARS) (REVERSE EARGS))
04700 (CLOSE) 'AUXB)
04800 (T (DISPATCH (CAR UARGS)
04900 'EVREST1
05000 '(VARS UARGS EARGS)
05100 ALINK))))
05200
05300 (DEFUN EVREST1 NIL (SETQ UARGS (CDR UARGS) EARGS (CONS VAL EARGS)) 'EVREST)
00100 (COMMENT WHEN RUN OUT OF ARGS BUT HAVE SOME "OPTIONAL"S OR "REST"S)
00200
00300 (DEFUN FINVAR ()
00400 (COND ((NULL VARS) 'AUXB)
00500 ((ATOM (CAR VARS))
00600 (COND ((EQ (CAR VARS) '"OPTIONAL") (SETQ VARS (CDR VARS))
00700 'FINVAR)
00800 ((EQ (CAR VARS) '"REST")
00900 (SETQ VARS (CDR VARS))
01000 (COND ((ATOM (CAR VARS)) (BIND1 (CAR VARS) NIL) 'AUXB)
01100 ((AND (EQ (CAAR VARS) 'QUOTE)
01200 (ATOM (CADAR VARS)))
01300 (BIND1 (CADAR VARS) NIL)
01400 'AUXB)
01500 (T (CERR BAD DECLARATION))))
01600 (T (BIND1 (CAR VARS) '*UNASSIGNED)
01700 (SETQ VARS (CDR VARS))
01800 'FINVAR)))
01900 ((EQ (CAAR VARS) 'QUOTE)
02000 (COND ((ATOM (CADAR VARS))
02100 (BIND1 (CADAR VARS) '*UNASSIGNED)
02200 (SETQ VARS (CDR VARS))
02300 'FINVAR)
02400 (T (CERR BAD DECLARATION))))
02500 ((ATOM (CAAR VARS))
02600 (DISPATCH (CADAR VARS) 'FINVAR1 '(VARS) '*TOP))
02700 ((AND (EQ (CAAAR VARS) 'QUOTE) (ATOM (CADAAR VARS)))
02800 (DISPATCH (CADAR VARS) 'FINVAR2 '(VARS) '*TOP))
02900 (T (CERR BAD DECLARATION))))
03000
03100 (DEFUN FINVAR1 NIL (BIND1 (CAAR VARS) VAL) (FINVAR3))
03200
03300 (DEFUN FINVAR2 NIL (BIND1 (CADAAR VARS) VAL) (FINVAR3))
03400
03500 (DEFUN FINVAR3 NIL (SETQ VARS (CDR VARS)) 'FINVAR)
03600
03700 (COMMENT BINDS "AUX" VARIABLES)
03800
03900 (DEFUN AUXB ()
04000 (SETQ BODY (BODY))
04100 (COND ((NULL BODY) (POPJ))
04200 ((EQ (CAR BODY) '"AUX")
04300 (SETQ VARS (CADR BODY))
04400 'AUXB1)
04500 (T 'LINE)))
04600
04700 (DEFUN AUXB1 NIL (COND ((NULL VARS) (SETQ BODY (CDDR (BODY))) 'LINE)
04800 ((ATOM (CAR VARS)) (BIND1 (CAR VARS) '*UNASSIGNED)
04900 (SETQ VARS (CDR VARS))
05000 'AUXB1)
05100 ((AND (ATOM (CAAR VARS)) (CDAR VARS))
05200 (DISPATCH (CADAR VARS)
05300 'AUXB2
05400 '(VARS)
05500 '*TOP))
05600 (T (CERR BAD DECLARATION))))
05700
05800 (DEFUN AUXB2 NIL (BIND1 (CAAR VARS) VAL) (SETQ VARS (CDR VARS)) 'AUXB1)
00100 (DEFUN CPROG NIL (BIND1 '*BODY (CDR EXP)) 'AUXB)
00200
00300 (DEFPROP PROG CPROG CINT)
00400
00500 (DEFUN PROGBIND () (DISPATCH (CADR EXP) 'PROGB1 NIL ALINK))
00600
00700 (DEFUN PROGB1 ()
00800 (BIND1 '*BODY (CONS '"AUX" (CONS (SETQ VARS VAL) (CDDR EXP))))
00900 'AUXB1)
01000
01100 (DEFPROP PROGBIND PROGBIND CINT)
01200
01300
01400 (COMMENT BASIC PROG ITERATION LOOP)
01500
01600 (DEFUN LINE ()
01700 (COND ((NULL BODY) (POPJ))
01800 (T (DISPATCH (CAR BODY) 'LINE1 '(BODY) '*TOP))))
01900
02000 (DEFUN LINE1 NIL (SETQ BODY (CDR BODY)) 'LINE)
02100
02200
02300 (COMMENT EVALUATES ARGUMENTS TO LISP EXPRS SUBRS AND LSUBRS)
02400
02500 (DEFUN EVARGS ()
02600 (COND ((NULL UARGS)
02700 (SETQ VAL (APPLY (CAR EXP) (REVERSE EARGS)))
02800 (POPJ))
02900 (T (DISPATCH (CAR UARGS) 'ARGS1 '(UARGS EARGS) ALINK))))
03000
03100 (DEFUN ARGS1 ()
03200 (SETQ UARGS (CDR UARGS) EARGS (CONS VAL EARGS)) 'EVARGS)
00100 (COMMENT LOGICAL FLOW OF CONTROL FUNCTIONS)
00200
00300 (DEFUN CCOND () (SETQ UARGS (CDR EXP)) (CONDLP))
00400
00500 (DEFUN CONDLP ()
00600 (COND ((NULL UARGS) (POPJ))
00700 (T (DISPATCH (CAAR UARGS) 'COND1 '(UARGS) ALINK))))
00800
00900 (DEFUN COND1 NIL (COND (VAL (BIND1 '*BODY (CDAR UARGS)) 'AUXB)
01000 (T (SETQ UARGS (CDR UARGS)) 'CONDLP)))
01100
01200 (DEFPROP COND CCOND CINT)
01300
01400
01500 (DEFUN IAND ()
01600 (COND ((NULL (SETQ EXP (CDR EXP))) (OR VAL (SETQ VAL T)) (POPJ))
01700 ((DISPATCH (CAR EXP) 'IAND1 '(EXP) '*TOP)) ))
01800
01900 (DEFUN IAND1 ()
02000 (COND (VAL 'IAND)
02100 ('POPJ) ))
02200
02300 (DEFPROP AND IAND CINT)
02400
02500
02600 (DEFUN IOR ()
02700 (COND ((NULL (SETQ EXP (CDR EXP))) (SETQ VAL NIL) (POPJ))
02800 ((DISPATCH (CAR EXP) 'IOR1 '(EXP) '*TOP)) ))
02900
03000 (DEFUN IOR1 ()
03100 (COND (VAL (POPJ))
03200 (T 'IOR) ))
03300
03400 (DEFPROP OR IOR CINT)
00100 (COMMENT USERS OF FRAMES -- FLOW OF CONTROL CONTROLLERS)
00200
00300 (DEFUN CGO NIL (DISPATCH (CADR EXP) 'GO1 NIL ALINK))
00400
00500 (DEFUN GO1 ()
00600 (COND ((ATOM VAL)
00700 (PROG (FR TAG B)
00800 (SETQ FR ALINK TAG '(/: FOO))
00900 (RPLACA (CDR TAG) VAL)
01000 LP (COND ((NULL FR) (SETQ VAL (CERR TAG NOT FOUND)) 'GO1)
01100 ((SETQ B (ASSQ '*BODY (BVARS FR)))
01200 (COND ((SETQ B (MEMBER TAG (CADR B)))
01300 (SETQ FRAME* FR)
01400 (RESTORE)
01500 (SETQ BODY B)
01600 (RETURN 'LINE)))))
01700 (SETQ FR (CLINK FR))
01800 (GO LP)))
01900 ((EQ (CAR VAL) '*TAG)
02000 (SETQ FRAME* (CADDR VAL))
02100 (RESTORE))
02200 (T (SETQ VAL (CERR BAD TAG)) 'GO1)))
02300
02400 (DEFPROP GO CGO CINT)
02500
02600 (DEFUN CEXIT NIL (DISPATCH (CADR EXP) 'EXIT1 () ALINK))
02700
02800 (DEFUN EXIT1 ()
02900 (SETQ TEM VAL)
03000 (COND ((CDDR EXP)
03100 (DISPATCH (CADDR EXP) 'EXIT2 '(TEM) ALINK))
03200 (T (PROG (FR)
03300 (SETQ FR ALINK)
03400 LP (COND ((NULL FR) (CERR EXIT FROM WHAT?))
03500 ((ASSQ '*BODY (BVARS FR))
03600 (SETQ CLINK (CLINK FR))
03700 (RETURN (POPJ))))
03800 (SETQ FR (CLINK FR))
03900 (GO LP)))))
04000
04100 (DEFUN EXIT2 ()
04200 (SETQ CLINK (CLINK (FR VAL)) VAL TEM)
04300 (POPJ))
04400
04500 (DEFPROP EXIT CEXIT CINT)
04600
04700 (DEFUN CRETURN NIL (DISPATCH (CADR EXP) 'RETURN1 NIL ALINK))
04800
04900 (DEFUN RETURN1 NIL (PROG (FR)
05000 (SETQ FR ALINK)
05100 LP (COND ((NULL FR) (CERR RETURN FROM WHAT?))
05200 ((AND (ASSQ '*BODY (BVARS FR))
05300 (NOT (EQ (CAR (EXP FR)) 'COND)))
05400 (SETQ CLINK (CLINK FR))
05500 (RETURN (POPJ))))
05600 (SETQ FR (CLINK FR))
05700 (GO LP)))
05800
05900 (DEFPROP RETURN CRETURN CINT) (DEFUN CDISMISS NIL (COND ((CDR EXP)
06000 (SETQ TEM ())
06100 (DISPATCH (CADR EXP) 'EXIT2 '(TEM) ALINK))
06200 (T (SETQ VAL ()) (RETURN1))))
06300
06400 (DEFPROP DISMISS CDISMISS CINT)
06500
06600 (DEFUN CONTINUE () (DISPATCH (CADR EXP) 'CONT1 () ALINK))
06700
06800 (DEFUN CONT1 ()
06900 (SETQ TEM VAL)
07000 (COND ((CDDR EXP) (DISPATCH (CADDR EXP) 'CONT2 '(TEM) ALINK))
07100 (T (SETQ VAL () FRAME* (FR TEM)) (RESTORE))))
07200
07300 (DEFUN CONT2 () (SETQ FRAME* (FR TEM)) (RESTORE))
07400
07500 (DEFPROP CONTINUE CONTINUE CINT) (COMMENT RELATIVE EVALUATORS)
07600
07700 (DEFUN ICEVAL NIL (DISPATCH (CADR EXP) 'CEVAL1 () ALINK))
07800
07900 (DEFUN CEVAL1 ()
08000 (SETQ TEM1 VAL)
08100 (COND ((CDDR EXP)
08200 (DISPATCH (CADDR EXP) 'CEVAL2 '(TEM1) ALINK))
08300 (T (SETQ VAL (FRAME)) 'CEVAL2)))
08400
08500 (DEFUN CEVAL2 ()
08600 (DISPATCH TEM1 'POPJ NIL (FR VAL)))
08700
08800 (DEFPROP CEVAL ICEVAL CINT)
08900
09000 (DEFUN ICALL NIL (DISPATCH (CADR EXP) 'CALL1 NIL ALINK))
09100
09200 (DEFUN CALL1 () (DISPATCH (CONS VAL (CDDR EXP)) 'POPJ NIL ALINK))
09300
09400 (DEFPROP CALL ICALL CINT)
09500
09600 (DEFUN INVOKE () (DISPATCH (CADR EXP) 'TRY1 () ALINK))
09700
09800 (DEFUN TRY1 () (SETQ TEM VAL) (DISPATCH (CADDR EXP) 'TRY2 '(TEM) ALINK))
09900
10000 (DEFUN TRY2 ()
10100 (SETQ EXP (LIST TEM VAL) FRAME* NIL)
10200 (PROG (AL METHPAT)
10300 (COND ((NULL (SETQ AL (MATCH (SETQ METHPAT (PATTERN TEM)) VAL)))
10400 (RETURN (POPJ)))
10500 (T (SETQ BVARS (NCONC (LIST (LIST '*CALLPAT VAL)
10600 (LIST '*METHPAT METHPAT)
10700 (LIST '*CALLALIST (CADR AL))
10800 (LIST '*BODY (TEXT TEM)))
10900 (CAR AL)))
11000 (CLOSE)
11100 (RETURN 'AUXB)))))
11200
11300 (DEFPROP INVOKE INVOKE CINT)
11400
11500 (DEFUN TEXT (METH)
11600 (COND ((ATOM METH) (TEXT (GET METH 'DATUM)))
11700 ((EQ (CAR METH) '*CLOSURE) (TEXT (CADR METH)))
11800 (T (CADDDR METH))))
11900
12000 (DEFUN FR (E)
12100 (COND ((EQ (CAR E) '*FRAME) (CADR E))
12200 ((EQ (CAR E) '*TAG) (CADDR E))
12300 ((EQ (CAR E) '*CLOSURE) (CADDR E))
12400 ((EQ (CAR E) '*AU-REVOIR) (CADR E))
12500 (T (CERR BAD FRAME SUPPLIED)))) (COMMENT IDENTIFIER MANIPULATORS)
12600
12700 (DEFUN VFRAME N
12800 (PROG (FR LOC)
12900 (SETQ FR (COND ((= N 1) ALINK)
13000 ((= N 2) (FR (ARG 2)))
13100 (T (CERR WRONG # OF ARGS))))
13200 LP (COND ((NULL FR) (RETURN NIL))
13300 ((SETQ LOC (ASSQ (ARG 1) (BVARS FR)))
13400 (RETURN (LIST '*FRAME (CHAUX FR) LOC))))
13500 (SETQ FR (ALINK FR))
13600 (GO LP)))
13700
13800 (DEFUN VLOC N (PROG (FR LOC)
13900 (SETQ FR (COND ((= N 1.)
14000 (COND ((SETQ LOC (ASSQ (ARG 1)
14100 BVARS))
14200 (RETURN LOC)))
14300 ALINK)
14400 ((= N 2.) (FR (ARG 2.)))
14500 (T (CERR WRONG # OF ARGS))))
14600 LP (COND ((NULL FR) (RETURN (ASSQ (ARG 1) GLOBALS)))
14700 ((SETQ LOC (ASSQ (ARG 1.) (BVARS FR)))
14800 (RETURN LOC)))
14900 (SETQ FR (ALINK FR))
15000 (GO LP)))
15100
15200 (DEFUN RVALUE N
15300 ((LAMBDA (LOC)
15400 (COND (LOC (COND ((CDDR LOC) (APPLY (CADDR LOC) (LIST 'RVALUE LOC))))
15500 (CADR LOC))
15600 (T (CERR UNBOUND VARIABLE @(ARG 1)))))
15700 (COND ((= N 1.) (VLOC (ARG 1.)))
15800 ((= N 2.) (VLOC (ARG 1.) (ARG 2.)))
15900 (T (CERR WRONG # OF ARGS)))))
16000
16100 (DECLARE (SPECIAL ID))
16200
16300 (DEFUN IVAL (ID FR)
16400 (PROG (ANS)
16500 (COND ((EQ FR '*TOP)
16600 (COND ((SETQ ANS (ASSQ ID BVARS))
16700 (GO FOUND))
16800 (T (SETQ FR ALINK)))))
16900 LP (COND ((NULL FR)
17000 (COND ((SETQ ANS (ASSQ ID GLOBALS)) (GO FOUND))
17100 (T (RETURN (CERR UNBOUND VARIABLE (/@ . ID))))))
17200 ((SETQ ANS (ASSQ ID (BVARS FR))) (GO FOUND)))
17300 (SETQ FR (ALINK FR))
17400 (GO LP)
17500 FOUND
17600 (COND ((CDDR ANS) (APPLY (CADDR ANS) (LIST '/, ANS))))
17700 (COND ((EQ (SETQ ANS (CADR ANS)) '*UNASSIGNED)
17800 (RETURN (CERR UNASSIGNED VARIABLE (/@ . ID)))))
17900 (RETURN ANS)))
18000
18100 (DECLARE (UNSPECIAL ID))
00100 (DEFUN ICSETQ () (SETQ UARGS EXP)(CSETQ0))
00200
00300 (DEFUN CSETQ0 ()
00400 (COND ((CDR UARGS)
00500 (COND ((AND (ATOM (CADR UARGS)) (CDDR UARGS))
00600 (DISPATCH (CADDR UARGS) 'CSETQ1 '(UARGS) ALINK))
00700 (T (CERR BAD CALL) (POPJ))))
00800 (T (POPJ))))
00900
01000 (DEFUN CSETQ1 ()
01100 ((LAMBDA (LOC)
01200 (COND (LOC (COND ((CDDR LOC) (APPLY (CADDR LOC) (LIST 'CSET LOC VAL))))
01300 (RPLACA (CDR LOC) VAL))
01400 (T (SETQ GLOBALS (CONS (LIST (CADR UARGS) VAL) GLOBALS)))))
01500 (VLOC (CADR UARGS)))
01600 (SETQ UARGS (CDDR UARGS))
01700 'CSETQ0)
01800
01900 (DEFUN CSETQ FEXPR (L)
02000 (CSET (CAR L) (EVAL (CADR L))) )
02100
02200 (DEFPROP CSETQ ICSETQ CINT)
02300
02400 (DEFUN CSET N
02500 ((LAMBDA (LOC)
02600 (COND (LOC (COND ((CDDR LOC) (APPLY (CADDR LOC) (LIST 'CSET LOC (ARG 2)))))
02700 (RPLACA (CDR LOC) (ARG 2.)))
02800 (T (SETQ GLOBALS (CONS (LIST (ARG 1) (ARG 2)) GLOBALS))))
02900 (ARG 2.))
03000 (COND ((= N 2.) (VLOC (ARG 1.)))
03100 ((= N 3.) (VLOC (ARG 1.) (ARG 3.)))
03200 (T (CERR WRONG # OF ARGS)))))
03300
03400 (DEFUN UNASSIGN (VAR) (CSET VAR '*UNASSIGNED)) (COMMENT FRAME CONSTRUCTORS)
03500
03600 (DEFUN CHAUX (FR)
03700 (COND ((NULL FR) NIL)
03800 ((EQ (CDAR FR) 'AUXB1)
03900 (CERR ATTEMPT TO RETURN INCOMPLETE FRAME))
04000 (T FR)))
04100
04200 (DEFUN TAG (NAME)
04300 (PROG (FR B TAG)
04400 (SETQ FR ALINK TAG '(/: FOO))
04500 (RPLACA (CDR TAG) NAME)
04600 LP (COND ((NULL FR) (RETURN NIL))
04700 ((SETQ B (ASSQ '*BODY (BVARS FR)))
04800 (COND ((SETQ B (MEMBER TAG (CADR B)))
04900 (CHAUX FR)
05000 (RETURN (LIST '*TAG NAME
05100 (CONS (CONS (LIST (CONS 'BODY B))
05200 'LINE)
05300 (CDR FR))))))))
05400 (SETQ FR (CLINK FR))
05500 (GO LP)))
05600
05700 (DEFUN ACTBLOCK ()
05800 (PROG (FR B)
05900 (SETQ FR ALINK)
06000 LP (COND ((NULL FR) (RETURN ()))
06100 ((SETQ B (ASSQ '*BODY (BVARS FR)))
06200 (CHAUX FR)
06300 (COND ((EQ (CAR B) '"AUX") (SETQ B (CDDR B))))
06400 (RETURN (LIST '*TAG '*ACTBLOCK
06500 (CONS (CONS (LIST (CONS 'BODY B)) 'LINE)
06600 (CDR FR))))))
06700 (SETQ FR (CLINK FR))
06800 (GO LP)))
06900
07000 (DEFUN ACCESS N
07100 (LIST '*FRAME
07200 (CHAUX (COND ((= N 0.) (ALINK ALINK))
07300 ((= N 1.) (ALINK (FR (ARG 1.))))
07400 (T (CERR WRONG # OF ARGS))))))
07500
07600 (DEFUN CONTROL N
07700 (LIST '*FRAME
07800 (CHAUX (COND ((= N 0.) (CLINK ALINK))
07900 ((= N 1.) (CLINK (FR (ARG 1))))
08000 (T (CERR WRONG # OF ARGS))))))
08100
08200 (DEFUN CLOSURE N
08300 (COND ((OR (< N 1) (> N 2)) (CERR WRONG # OF ARGS)) )
08400 (LIST '*CLOSURE (ARG 1) (CHAUX (COND ((= N 2) (FR (ARG 2)))
08500 (T ALINK)) )) )
08600
08700 (DEFUN FRAME NIL (LIST '*FRAME (CHAUX ALINK))) (COMMENT VERY DANGEROUS USER (HA!) FUNCTIONS)
08800
08900 (DEFUN SETACCESS (T1 S)
09000 (SETQ T1 (FR T1) S (FR S))
09100 (RPLACD (CADR T1) S)
09200 'BOOM!)
09300
09400 (DEFUN SETCONTROL (T1 S)
09500 (SETQ T1 (FR T1) S (FR S))
09600 (RPLACD (CDDR T1) S)
09700 'BOOM!)
09800
09900 (DEFUN CEVAL N
10000 ((LAMBDA (PC EXP ALINK)
10100 (PROG (CLINK FRAME* BVARS CHALOBV RUNF) (RETURN (RUN1))))
10200 'ICEVAL
10300 (LIST 'CEVAL (LIST 'QUOTE (ARG 1)))
10400 (COND ((> N 1) (FR (ARG 2))) (T ALINK)))) (COMMENT DEBUGGING AIDS)
10500
10600 (DEFUN EXPRESSION (F) (EXP (FR F)))
10700
10800 (DEFUN BACKTRACE N (PROG (FR E B M TEM)
10900 (SETQ FR (FRAME))
11000 (COND ((= N 0.) (SETQ M 262143.))
11100 (T (SETQ M (ARG 1.))))
11200 (COND ((= N 2.) (SETQ TEM (ARG 2.))))
11300 LP (COND ((OR (NULL (CADR FR)) (= M 0.))
11400 (RETURN 'END-OF-BACKTRACE)))
11500 (SETQ E (EXPRESSION FR))
11600 (COND ((SETQ B (GET (CAR E) 'BACKTRACE))
11700 (APPLY B (LIST FR (CDR E))))
11800 (T (CPRINT E)))
11900 (COND (TEM (CPRIN1 (CAADR FR))))
12000 (SETQ FR (CONTROL FR))
12100 (SETQ M (/1- M))
12200 (GO LP)))
12300
12400 (DEFUN LISTENB
12500 (FR ARG)
12600 (PRINT (IVAL 'EAR (CADR FR)))
12700 (CPRIN1 (IVAL 'MESSAGE (CADR FR)))
12800 (PRINC '/ ))
12900
13000 (DEFPROP LISTEN LISTENB BACKTRACE)
13100
13200 (DEFUN CONDB (FR ARG) (PRINT 'COND))
13300
13400 (DEFPROP COND CONDB BACKTRACE)
13500
13600 (DEFUN PROGB (FR ARG) (PRINT 'PROG))
13700
13800 (DEFPROP PROG PROGB BACKTRACE)
13900
14000 (DEFUN CEVALB (FR ARG) (COND (TEM (PRINT 'CEVAL))))
14100
14200 (DEFPROP CEVAL CEVALB BACKTRACE)
14300
14400 (DEFUN UPDATEB (FR ARG) ())
14500
14600 (DEFPROP UPDATE UPDATEB BACKTRACE)
14700
14800 (DEFUN SETB (FR ARG)
14900 (OR (MEMBER (CAR ARG) '('* '**))
15000 (PRINT (CONS 'SET ARG))))
15100
15200 (DEFPROP SET SETB BACKTRACE)
15300
15400 (DEFUN PROGBINDB (FR ARG) (PRINT 'PROGBIND))
15500
15600 (DEFPROP PROGBIND PROGBINDB BACKTRACE)
00100 (COMMENT USER INTERFACE)
00200
00300 (DEFUN CDEFUN FEXPR (L) (PUTPROP (CAR L) (CDR L) 'CEXPR) (CAR L))
00400
00500 (CDEFUN LISTEN (MESSAGE) "AUX"((EAR (GENLEV)))
00600 (ALLOW T)
00700 (CPRINT MESSAGE)
00800 (PROGBIND (LIST EAR 'LOOP)
00900 (CSET EAR (TAG 'EAR))
01000 (CSETQ LOOP (TAG 'LOOP))
01100 (/: EAR)
01200 (PRINT EAR)
01300 (/: LOOP)
01400 (SETQ ← **)
01500 (/@ PRINT '/←)
01700 (SET '* (CEVAL (SETQ ** (READ))))
01800 (/@ CPRINT *)
01900 (GO LOOP)))
02000
02100 (DEFUN GENLEV NIL (READLIST (APPEND '(E A R -)
02200 (EXPLODE (SETQ LEVNUM (ADD1 LEVNUM))))))
02300
02400 (DEFUN /: FEXPR (L) L)
02500
02600 (DEFUN /@ FEXPR (\L) (EVAL \L))
02700
02800 (DEFUN /, FEXPR (L) (IVAL (CAR L) '*TOP))
00100 (DEFUN CPRIN1 (X)
00200 (PROG (Y)
00300 (COND ((ATOM X) (PRIN1 X) (RETURN X))
00400 ((AND (ATOM (CAR X)) (SETQ Y (GET (CAR X) 'CPRINT)))
00500 (APPLY Y X) (RETURN X)))
00600 (SETQ Y X)
00700 (PRINC '/()
00800 PLOOP
00900 (CPRIN1 (CAR Y))
01000 (COND ((NULL (SETQ Y (CDR Y))) (PRINC '/)) (RETURN X))
01100 ((ATOM Y) (PRINC '/ /./ ) (PRIN1 Y) (PRINC '/)) (RETURN X)))
01200 (PRINC '/ )
01300 (GO PLOOP)))
01400
01500 (DEFUN CPRINT (X) (PRINC '//
01600 ) (CPRIN1 X) (PRINC '/ ) X)
01700
01800 (DEFUN CP-MACR FEXPR (E) (PRINC (CAR E)) (PRIN1 (CADR E)))
01900 (DEFPROP /: CP-MACR CPRINT)
02000 (DEFPROP /, CP-MACR CPRINT)
02100
02200 (DEFUN CP-QUOTE FEXPR (E) (PRINC '/') (CPRIN1 (CADR E)))
02300 (DEFPROP QUOTE CP-QUOTE CPRINT)
02400
02500 (DEFUN CP-*TAG FEXPR (TAG)
02600 (PRINC '/()
02700 (PRIN1 (CAR TAG))
02800 (PRINC '/ )
02900 (CPRIN1 (CADR TAG))
03000 (PRINC '/ )
03100 (CPRIN1 (EXP (CADDR TAG)))
03200 (PRINC '/)))
03300 (DEFPROP *TAG CP-*TAG CPRINT)
03400 (DEFPROP *CLOSURE CP-*TAG CPRINT)
03500
03600 (DEFUN CP-*FRAME FEXPR (FRAME)
03700 (PRINC '/()
03800 (PRIN1 (CAR FRAME))
03900 (PRINC '/ )
04000 (CPRIN1 (EXP (CADR FRAME)))
04100 (PRINC '/)))
04200 (DEFPROP *FRAME CP-*FRAME CPRINT)
04300 (DEFPROP *AU-REVOIR CP-*FRAME CPRINT)
04400
04500 (DEFUN CP-MATCH FEXPR (E)
04600 (PRINC (CAR E))
04700 (COND ((CDDR E) (CPRIN1 (CDR E)))
04800 ((CADR E) (CPRIN1 (CADR E)) )))
04900
05000 (DEFPROP /!/> CP-MATCH CPRINT)
05100 (DEFPROP /!/' CP-MATCH CPRINT)
05200 (DEFPROP /!/? CP-MATCH CPRINT)
05300 (DEFPROP /!/; CP-MATCH CPRINT)
05400 (DEFPROP /!/< CP-MATCH CPRINT)
05500 (DEFPROP /!/, CP-MATCH CPRINT)
05600 (DEFPROP /!/@ CP-MATCH CPRINT)
05700
05800 (DEFUN CP-/!/" FEXPR (E) (PRINC (CAR E)) (CPRIN1 (CDR E)))
05900 (DEFPROP /!/" CP-/!/" CPRINT)
06000 (DEFPROP /@ CP-/!/" CPRINT) (DEFUN COLMAC NIL (LIST '/: (READ)))
06100
06200 (DEFUN COMMAC () (LIST '/, (READ)))
06300
06400 (DEFUN ATMAC () (CONS '/@ (READ)))
06500
06600 (DEFUN EXMAC ()
06700 (PROG (C F)
06800 (SETQ C (NXTCHR))
06900 (COND ((EQ C '/$) (TYI)
07000 (RETURN ((LAMBDA (OBARRAY) (READ))
07100 (GET 'CONNIVER 'ARRAY))))
07200 ((EQ C '/") (TYI) (RETURN (CONS '/!" (READ))))
07300 ((SETQ F (ASSQ C '((/? /!/?) (/' /!/') (/@ /!/@) (/> /!/>)
07400 (/, /!/,) (/< /!/<) (/; /!/;))))
07500 (TYI)
07600 (SETQ F (CADR F)))
07700 (T (PRINT (LIST 'BAD '/! 'MACRO C)) (IOC G)))
07800 (RETURN (COND ((SEPARATOR (NXTCHR)) (LIST F NIL))
07900 ((ATOM (SETQ C (READ))) (LIST F C))
08000 (T (CONS F C))))))
08100
08200 (DEFUN NXTCHR () (ASCII (TYIPEEK)))
08300
08400 (DEFUN SEPARATOR (CHAR) (MEMQ CHAR '(/ / /) )))
08500
08600 (MAKREADTABLE 'CONNIVREAD)
08700
08800 ((LAMBDA (READTABLE)
08900 (SSTATUS MACRO /: 'COLMAC)
09000 (SSTATUS MACRO /, 'COMMAC)
09100 (SSTATUS MACRO /@ 'ATMAC)
09200 (SSTATUS MACRO /! 'EXMAC))
09300 (GET 'CONNIVREAD 'ARRAY))
09400